home *** CD-ROM | disk | FTP | other *** search
/ Clipart Warehouse 1 (Chestnut) / Clipart Warehouse.iso / utils / giftech / degifer.pas < prev    next >
Pascal/Delphi Source File  |  1993-04-30  |  5KB  |  168 lines
  1. Program GIF;
  2. uses CRT,GRAPH3,DEGIF;
  3.  
  4. var  InFileName:string;   BlockType:char;
  5.      I,NewBottom,NewLeft,NewRight,NewTop,
  6.      OffLeft,OffTop,Pass,XCord,YCord:integer;
  7.      InFile:File;
  8.      Buffer:array[0..32767] of byte;
  9.      BufIndx,Count:word;
  10.      Done,EOFin,SkipIt,Smash,Squeeze:Boolean;
  11.  
  12. procedure quit;
  13.  begin
  14.   close(output);textmode(co80);halt
  15.  end;
  16.  
  17. procedure Abort;
  18.  begin
  19.   close(InFile);Quit
  20.  end;
  21.  
  22. {$F+}
  23. function GetByte: byte;
  24. begin
  25.  if not Done
  26.   then begin
  27.         if BufIndx >= Count
  28.          then begin
  29.                Done:=EOFIn;BlockRead(InFile,Buffer,SizeOf(Buffer),Count);
  30.                EOFIn:=Count < sizeof(Buffer); BufIndx:=0
  31.               end;
  32.         GetByte:=Buffer[BufIndx]; Inc(BufIndx)
  33.        end
  34.   else GetByte:=0
  35. end;
  36. {$F-}
  37.  
  38. {$F+}
  39. procedure PutByte(Pix: integer);
  40. const YInc:array [1..5] of integer=(8,8,4,2,1);
  41.       YLin:array [1..5] of integer=(0,4,2,1,0);
  42. var x,y:integer;
  43. begin
  44.  if Squeeze then x:=XCord shr 1 else x:=XCord;
  45.  if Smash   then y:=YCord shr 1 else y:=YCord;
  46.  if SkipIt  then {nop}
  47.             else Plot(X,Y,Color[CurMap,Pix]);
  48.  Inc(XCord);
  49.  if XCord = NewRight
  50.   then begin XCord:=NewLeft;
  51.              if KeyPressed then Abort;
  52.              Inc(YCord,YInc[Pass]);
  53.              SkipIt:=Smash and ((YCord and 1)=1);
  54.              if YCord >= NewBottom
  55.               then begin Inc(Pass); YCord:=YLin[Pass]+NewTop end
  56.        end
  57. end;
  58. {$F-}
  59.  
  60. procedure DoMapping;
  61.  var I:integer;
  62.  begin
  63.   for I:=0 to NumberOfColors[CurMap]-1 do Color[CurMap,I]:=I mod 4
  64.  end;
  65.  
  66. procedure AdjustImage;
  67.  begin
  68.   NewLeft  := ImageLeft + OffLeft;
  69.   NewTop   := ImageTop + OffTop;
  70.   NewRight := ImageWidth + NewLeft;
  71.   NewBottom:= ImageHeight + NewTop;
  72.   XCord:=NewLeft;   YCord:=NewTop;
  73.   if Interlaced then Pass:=1 else Pass:=5;
  74.  end;
  75.  
  76. procedure DisplayScrDes;
  77. var I:integer;
  78.     AnsCh:char;
  79. begin
  80.  Writeln('Screen width =',ScreenWidth:5, '  Screen height   =',ScreenHeight:5);
  81.  Writeln('Bits of color=',BitsOfColorPerPrimary:5,
  82.          '  Number of colors=',NumberOfColors[Global]:5);
  83.  OffLeft:=0; OffTop:=0;
  84.  Smash:=false; Squeeze:=false;
  85.  if ScreenHeight>200 then
  86.   begin
  87.    write('Screen Height is ',ScreenHeight:5,' do you want to Smash it? [Y]  ');
  88.    AnsCh:=ReadKey;
  89.    Smash:=AnsCh in [#13,'Y','y'];
  90.    if Smash then begin writeln('Smashing'); I:=ScreenHeight div 2 end
  91.             else I:=ScreenHeight;
  92.    if I > 200
  93.     then
  94.      begin
  95.       write('Screen too tall.  What line should I begin with? ');Readln(OffTop);
  96.       OffTop:=-OffTop
  97.      end
  98.   end;
  99.  if ScreenWidth > 320
  100.   then
  101.    begin
  102.     write('Screen width ',ScreenWidth:5,' do you want to squeeze it? [Y]  ');
  103.     AnsCh:=ReadKey;
  104.     Squeeze:=AnsCh in [#13,'Y','y'];
  105.     if Squeeze then begin writeln('Squeezing'); I:=ScreenWidth div 2 end
  106.                else I:=ScreenWidth;
  107.     if I > 200
  108.      then
  109.       begin
  110.        write('Screen too wide.  What column should I begin with? ');Readln(OffLeft);
  111.        OffLeft:=-OffLeft
  112.       end
  113.    end;
  114.  end;
  115.  
  116. begin
  117.  AddrGetByte:=@GetByte;
  118.  AddrPutByte:=@PutByte;
  119.  AssignCrt(output);Rewrite(OUTPUT);
  120.  writeln('DeGIFer version 0.1 demo for DEGIF Turbo Pascal Unit');
  121.  writeln('  Copyright (c) 1988 Cyborg Software Systems, Inc.');writeln;
  122.  writeln('     GIF and "Graphics Interchange Format" are');
  123.  writeln('    trademarks (tm) of CompuServe Incorporated');
  124.  writeln('           an H&R Block Company.');writeln;writeln;
  125.  if paramcount=0
  126.   then begin
  127.         write('Enter GIF file name:  '); readln(infilename);
  128.        end
  129.   else InFileName:=paramstr(1);
  130.  if length(InFileName)>0 then
  131.   begin
  132.    assign(InFile,InFileName);
  133.    {$I-}
  134.    reset(InFile,1);
  135.    if ioresult<>0
  136.     then begin writeln('GIF datafile could not be found.'); Quit end;
  137.    SkipIt:=false;
  138.    EOFin:=false;
  139.    Done:=false;
  140.    BufIndx:=999;Count:=0;
  141.    CurMap:=Global;
  142.    GetGIFSig;
  143.    if GIFSig<>'GIF87a' then begin writeln('Invalid GIF ID'); Abort end;
  144.    GetScrDes;
  145.    DisplayScrDes;
  146.    if MapExists[Global] then GetColorMap;
  147.    DoMapping;
  148.    writeln('Press <Enter> to display');  readln;
  149.    GraphColorMode;
  150.    while not Done Do
  151.     begin
  152.      BlockType:=chr(GetByte);
  153.      case BlockType of
  154.       ',':begin
  155.            GetImageDescription;
  156.            AdjustImage;
  157.            if MapExists[Local]
  158.             then begin CurMap:=Local; GetColorMap; DoMapping end
  159.             else CurMap:=Global;
  160.            if ExpandGIF <>0 then Halt
  161.           end;
  162.       '!':SkipExtendBlock;
  163.      end;
  164.     end;
  165.   end;
  166.  Sound(440);Delay(100);NoSound;Readln;Abort;
  167. end.
  168.